home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / cmpnew / cmplam.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  29KB  |  838 lines
  1. ;;; CMPLAM  Lambda expression.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. ;;; During Pass1, a lambda-list
  10. ;;;
  11. ;;; (    { var }*
  12. ;;;     [ &optional { var | ( var [ initform [ svar ] ] ) }* ]
  13. ;;;     [ &rest var ]
  14. ;;;     [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}*
  15. ;;;         [&allow-other-keys]]
  16. ;;;     [ &aux {var | (var [initform])}*]
  17. ;;; )
  18. ;;;
  19. ;;; is transformed into
  20. ;;;
  21. ;;; (    ( { var }* )                ; required
  22. ;;;     ( { (var initform svar) }* )        ; optional
  23. ;;;     { var | nil }                ; rest
  24. ;;;     key-flag
  25. ;;;     ( { ( kwd-vv-index var initform svar) }* )    ; key
  26. ;;;     allow-other-keys-flag
  27. ;;; )
  28. ;;;
  29. ;;; where
  30. ;;;     svar:      nil        ; means svar is not supplied
  31. ;;;            | var
  32. ;;;
  33. ;;; &aux parameters will be embedded into LET*.
  34. ;;;
  35. ;;; c1lambda-expr receives
  36. ;;;    ( lambda-list { doc | decl }* . body )
  37. ;;; and returns
  38. ;;;    ( lambda info-object lambda-list' doc body' )
  39. ;;;
  40. ;;; Doc is NIL if no doc string is supplied.
  41. ;;; Body' is body possibly surrounded by a LET* (if &aux parameters are
  42. ;;; supplied) and an implicit block.
  43.  
  44. (defmacro ck-spec (condition)
  45.   `(unless ,condition
  46.            (cmperr "The parameter specification ~s is illegal." spec)))
  47.  
  48. (defmacro ck-vl (condition)
  49.   `(unless ,condition
  50.            (cmperr "The lambda list ~s is illegal." vl)))
  51.  
  52. (defun c1lambda-expr (lambda-expr
  53.                       &optional (block-name nil block-it)
  54.                       &aux (requireds nil) (optionals nil) (rest nil)
  55.                            (keywords nil) (key-flag nil)
  56.                            (allow-other-keys nil) (aux-vars nil)
  57.                            (aux-inits nil) doc vl spec body ss is ts
  58.                            other-decls vnames
  59.                            (*vars* *vars*)
  60.                            (info (make-info))
  61.                            (aux-info nil)
  62.                       )
  63.   (cmpck (endp lambda-expr)
  64.          "The lambda expression ~s is illegal." (cons 'lambda lambda-expr))
  65.  
  66.   (multiple-value-setq (body ss ts is other-decls doc)
  67.                        (c1body (cdr lambda-expr) t))
  68.  
  69.   (when block-it (setq body (list (cons 'block (cons block-name body)))))
  70.  
  71.   (c1add-globals ss)
  72.  
  73.   (setq vl (car lambda-expr))
  74.   (block parse
  75.    (tagbody
  76.     Lreq
  77.       (when (null vl) (return-from parse))
  78.       (ck-vl (consp vl))
  79.       (case (setq spec (pop vl))
  80.             (&optional (go Lopt))
  81.             (&rest (go Lrest))
  82.             (&key (go Lkey))
  83.             (&aux (go Laux)))
  84.       (let ((v (c1make-var spec ss is ts)))
  85.            (push spec vnames)
  86.            (push v *vars*)
  87.            (push v requireds))
  88.       (go Lreq)
  89.  
  90.     Lopt
  91.       (when (null vl) (return-from parse))
  92.       (ck-vl (consp vl))
  93.       (case (setq spec (pop vl))
  94.             (&rest (go Lrest))
  95.             (&key (go Lkey))
  96.             (&aux (go Laux)))
  97.       (cond ((not (consp spec))
  98.              (let ((v (c1make-var spec ss is ts)))
  99.                   (push spec vnames)
  100.                   (push (list v (default-init (var-type v)) nil) optionals)
  101.                   (push v *vars*)))
  102.             ((not (consp (cdr spec)))
  103.              (ck-spec (null (cdr spec)))
  104.              (let ((v (c1make-var (car spec) ss is ts)))
  105.                   (push (car spec) vnames)
  106.                   (push (list v (default-init (var-type v)) nil) optionals)
  107.                   (push v *vars*)))
  108.             ((not (consp (cddr spec)))
  109.              (ck-spec (null (cddr spec)))
  110.              (let ((init (c1expr* (cadr spec) info))
  111.                    (v (c1make-var (car spec) ss is ts)))
  112.                   (push (car spec) vnames)
  113.                   (push
  114.                    (list v (and-form-type (var-type v) init (cadr spec)) nil)
  115.                    optionals)
  116.                   (push v *vars*)))
  117.             (t
  118.              (ck-spec (null (cdddr spec)))
  119.              (let ((init (c1expr* (cadr spec) info))
  120.                    (v (c1make-var (car spec) ss is ts))
  121.                    (sv (c1make-var (caddr spec) ss is ts))
  122.                    )
  123.                   (push (car spec) vnames)
  124.                   (push (caddr spec) vnames)
  125.                   (push
  126.                    (list v (and-form-type (var-type v) init (cadr spec)) sv)
  127.                    optionals)
  128.                   (push v *vars*)
  129.                   (push sv *vars*))))
  130.       (go Lopt)
  131.  
  132.     Lrest
  133.       (ck-vl (consp vl))
  134.       (push (car vl) vnames)
  135.       (setq rest (c1make-var (pop vl) ss is ts))
  136.       (push rest *vars*)
  137.       (when (null vl) (return-from parse))
  138.       (ck-vl (consp vl))
  139.       (case (setq spec (pop vl))
  140.             (&key (go Lkey))
  141.             (&aux (go Laux)))
  142.       (cmperr "Either &key or &aux is missing before ~s." spec)
  143.  
  144.     Lkey
  145.       (setq key-flag t)
  146.       (when (null vl) (return-from parse))
  147.       (ck-vl (consp vl))
  148.       (case (setq spec (pop vl))
  149.             (&aux (go Laux))
  150.             (&allow-other-keys (setq allow-other-keys t)
  151.                                (when (null vl) (return-from parse))
  152.                                (ck-vl (consp vl))
  153.                                (case (setq spec (pop vl))
  154.                                      (&aux (go Laux)))
  155.                                (cmperr "&aux is missing before ~s." spec)))
  156.       (when (not (consp spec)) (setq spec (list spec)))
  157.       (cond ((consp (car spec))
  158.              (ck-spec (and (keywordp (caar spec))
  159.                            (consp (cdar spec))
  160.                            (null (cddar spec))))
  161.              (setq spec (cons (caar spec) (cons (cadar spec) (cdr spec)))))
  162.             (t
  163.              (ck-spec (symbolp (car spec)))
  164.              (setq spec (cons (intern (string (car spec)) 'keyword)
  165.                               (cons (car spec) (cdr spec))))))
  166.       (cond ((not (consp (cddr spec)))
  167.              (ck-spec (null (cddr spec)))
  168.              (let ((v (c1make-var (cadr spec) ss is ts)))
  169.                   (push (cadr spec) vnames)
  170.                   (push
  171.                    (list (car spec) v (default-init (var-type v))
  172.                          (make-var :kind 'DUMMY))
  173.                    keywords)
  174.                   (push v *vars*)))
  175.             ((not (consp (cdddr spec)))
  176.              (ck-spec (null (cdddr spec)))
  177.              (let ((init (c1expr* (caddr spec) info))
  178.                    (v (c1make-var (cadr spec) ss is ts)))
  179.                   (push (cadr spec) vnames)
  180.                   (push (list (car spec) v
  181.                               (and-form-type (var-type v) init (caddr spec))
  182.                               (make-var :kind 'DUMMY))
  183.                         keywords)
  184.                   (push v *vars*)))
  185.             (t
  186.              (ck-spec (null (cddddr spec)))
  187.              (let ((init (c1expr* (caddr spec) info))
  188.                    (v (c1make-var (cadr spec) ss is ts))
  189.                    (sv (c1make-var (cadddr spec) ss is ts)))
  190.                   (push (cadr spec) vnames)
  191.                   (push (cadddr spec) vnames)
  192.                   (push (list (car spec) v
  193.                               (and-form-type (var-type v) init (caddr spec))
  194.                               sv)
  195.                         keywords)
  196.                   (push v *vars*)
  197.                   (push sv *vars*))))
  198.       (go Lkey)
  199.  
  200.     Laux
  201.       (setq aux-info (make-info))
  202.     Laux1
  203.       (when (null vl) (add-info info aux-info) (return-from parse))
  204.       (ck-vl (consp vl))
  205.       (setq spec (pop vl))
  206.       (cond ((consp spec)
  207.              (cond ((not (consp (cdr spec)))
  208.                     (ck-spec (null (cdr spec)))
  209.                     (let ((v (c1make-var (car spec) ss is ts)))
  210.                          (push (car spec) vnames)
  211.                          (push (default-init (var-type v)) aux-inits)
  212.                          (push v aux-vars)
  213.                          (push v *vars*)))
  214.                    (t
  215.                     (ck-spec (null (cddr spec)))
  216.                     (let ((init (c1expr* (cadr spec) aux-info))
  217.                           (v (c1make-var (car spec) ss is ts)))
  218.                          (push (car spec) vnames)
  219.                          (push (and-form-type (var-type v) init (cadr spec))
  220.                                aux-inits)
  221.                          (push v aux-vars)
  222.                          (push v *vars*)))))
  223.             (t
  224.              (let ((v (c1make-var spec ss is ts)))
  225.                   (push spec vnames)
  226.                   (push (default-init (var-type v)) aux-inits)
  227.                   (push v aux-vars)
  228.                   (push v *vars*))))
  229.       (go Laux1)
  230.       )
  231.    )
  232.   (setq requireds (reverse requireds)
  233.         optionals (reverse optionals)
  234.         keywords (reverse keywords)
  235.         aux-vars (reverse aux-vars)
  236.         aux-inits (reverse aux-inits))
  237.  
  238.   (check-vdecl vnames ts is)
  239.  
  240.   (setq body (c1decl-body other-decls body))
  241.  
  242.   (add-info info (cadr body))
  243.  
  244.   (dolist** (var requireds) (check-vref var))
  245.   (dolist** (opt optionals)
  246.             (check-vref (car opt))
  247.             (when (caddr opt) (check-vref (caddr opt))))
  248.   (when rest (check-vref rest))
  249.   (dolist** (kwd keywords)
  250.             (check-vref (cadr kwd))
  251.             (when (cadddr kwd) (check-vref (cadddr kwd))))
  252.   (dolist** (var aux-vars) (check-vref var))
  253.  
  254.   (when aux-vars
  255.         (add-info aux-info (cadr body))
  256.         (setq body (list 'let* aux-info aux-vars aux-inits body)))
  257.  
  258.   (list 'lambda
  259.         info
  260.         (list requireds optionals rest key-flag keywords allow-other-keys)
  261.         doc
  262.         body)
  263.   )
  264.  
  265. (defun the-parameter (name)
  266.   (cmpck (not (symbolp name)) "The parameter ~s is not a symbol." name)
  267.   (cmpck (constantp name) "The constant ~s is being bound." name)
  268.   name
  269.   )
  270.  
  271. (defun c2lambda-expr (lambda-list body &optional (fname nil s-fname))
  272.   (let ((*tail-recursion-info*            ;;; Tail recursion possible if
  273.          (if (and *do-tail-recursion*
  274.                   s-fname            ;;; named function,
  275.                   (dolist* (var (car lambda-list) t)
  276.                     (when (var-ref-ccb var) (return nil)))
  277.                 ;;; no required is closed in a closure,
  278.                   (null (cadr lambda-list))    ;;; no optionals,
  279.                   (null (caddr lambda-list))    ;;; no rest parameter, and
  280.                   (not (cadddr lambda-list)))    ;;; no keywords.
  281.              (cons fname (car lambda-list))
  282.              nil)))
  283.        (if (cadddr lambda-list) ;;; key-flag
  284.            (c2lambda-expr-with-key lambda-list body)
  285.            (c2lambda-expr-without-key lambda-list body)))
  286.   )
  287.  
  288. (defun c2lambda-expr-without-key
  289.        (lambda-list body
  290.         &aux (requireds (car lambda-list))
  291.              (optionals (cadr lambda-list))
  292.              (rest (caddr lambda-list))
  293.              (labels nil)
  294.              (*unwind-exit* *unwind-exit*)
  295.              (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)
  296.              (block-p nil)
  297.         )
  298.   (declare (object requireds optionals rest))
  299.   ;;; Allocate immediate-type parameters.
  300.  
  301.   (flet ((do-decl (var)
  302.            (let ((kind (c2var-kind var)))
  303.                 (declare (object kind))
  304.                 (when kind
  305.                       (let ((cvar (next-cvar)))
  306.                            (setf (var-kind var) kind)
  307.                            (setf (var-loc var) cvar)
  308.                            (wt-nl)
  309.                            (unless block-p (wt "{") (setq block-p t))
  310.                            (wt (rep-type kind) "V" cvar ";"))))))
  311.  
  312.         (dolist** (v requireds) (do-decl v))
  313.         (dolist** (opt optionals)
  314.                   (do-decl (car opt))
  315.                   (when (caddr opt) (do-decl (caddr opt))))
  316.         (when rest (do-decl rest))
  317.         )
  318.   ;;; check arguments
  319.   (when (or *safe-compile* *compiler-check-args*)
  320.     (cond ((or rest optionals)
  321.            (when requireds
  322.              (wt-nl "if(vs_top-vs_base<" (length requireds)
  323.                     ") too_few_arguments();"))
  324.            (unless rest
  325.              (wt-nl "if(vs_top-vs_base>"
  326.                     (+ (length requireds) (length optionals))
  327.                     ") too_many_arguments();")))
  328.           (t (wt-nl "check_arg(" (length requireds) ");"))))
  329.  
  330.   ;;; Allocate the parameters.
  331.   (dolist** (var requireds) (setf (var-ref var) (vs-push)))
  332.   (dolist** (opt optionals) (setf (var-ref (car opt)) (vs-push)))
  333.   (when rest (setf (var-ref rest) (vs-push)))
  334.   (dolist** (opt optionals)
  335.             (when (caddr opt) (setf (var-ref (caddr opt)) (vs-push))))
  336.  
  337.   ;;; Bind required parameters.
  338.   (dolist** (var requireds) (c2bind var))
  339.  
  340.   ;;; Bind optional parameters as long as there remain arguments.
  341.   ;;; The compile-time binding is discarded because they are bound again.
  342.   (when (and (or optionals rest) (not (null requireds)))
  343.         (wt-nl "vs_base=vs_base+" (length requireds) ";"))
  344.   (cond (optionals
  345.          (let ((*clink* *clink*)
  346.                (*unwind-exit* *unwind-exit*)
  347.                (*ccb-vs* *ccb-vs*))
  348.            (do ((opts optionals (cdr opts)))
  349.                ((endp opts))
  350.                (declare (object opts))
  351.              (push (next-label) labels)
  352.              (wt-nl "if(vs_base>=vs_top){")
  353.              (reset-top)
  354.              (wt-go (car labels)) (wt "}")
  355.              (c2bind (caar opts))
  356.              (when (caddar opts) (c2bind-loc (caddar opts) t))
  357.              (when (or (cdr opts) rest) (wt-nl "vs_base++;"))
  358.              )
  359.  
  360.            (when rest
  361.              (wt-nl "vs_top[0]=Cnil;")
  362.              (wt-nl "{object *p=vs_top;")
  363.              (wt-nl " for(;p>vs_base;p--)p[-1]=MMcons(p[-1],p[0]);}")
  364.              (c2bind rest))
  365.            )
  366.  
  367.          (wt-nl) (reset-top)
  368.  
  369.          (let ((label (next-label)))
  370.            (wt-nl) (wt-go label)
  371.  
  372.            (setq labels (reverse labels))
  373.  
  374.            ;;; Bind unspecified optional parameters.
  375.            (dolist** (opt optionals)
  376.              (wt-label (car labels))
  377.              (pop labels)
  378.              (c2bind-init (car opt) (cadr opt))
  379.              (when (caddr opt) (c2bind-loc (caddr opt) nil)))
  380.  
  381.              (when rest (c2bind-loc rest nil))
  382.  
  383.              (wt-label label)))
  384.         (rest
  385.          (wt-nl "vs_top[0]=Cnil;")
  386.          (wt-nl "{object *p=vs_top;")
  387.          (wt-nl " for(;p>vs_base;p--)p[-1]=MMcons(p[-1],p[0]);}")
  388.          (c2bind rest)
  389.          (wt-nl)
  390.          (reset-top))
  391.         (t
  392.          (wt-nl)
  393.          (reset-top)))
  394.  
  395.   (when *tail-recursion-info*
  396.         (push 'tail-recursion-mark *unwind-exit*) (wt-nl1 "TTL:;"))
  397.  
  398.   ;;; Now the parameters are ready!
  399.   (c2expr body)
  400.  
  401.   (when block-p (wt-nl "}"))
  402.   )
  403.  
  404. (defun c2lambda-expr-with-key
  405.        (lambda-list body
  406.         &aux (requireds (nth 0 lambda-list))
  407.              (optionals (nth 1 lambda-list))
  408.              (rest (nth 2 lambda-list))
  409.              (keywords (nth 4 lambda-list))
  410.              (allow-other-keys (nth 5 lambda-list))
  411.              (labels nil)
  412.              (*unwind-exit* *unwind-exit*)
  413.              (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)
  414.              (block-p nil)
  415.              )
  416.   (declare
  417.    (object requireds optionals rest keywords allow-other-keys))
  418.   ;;; Allocate immediate-type parameters.
  419.   (flet ((do-decl (var)
  420.            (let ((kind (c2var-kind var)))
  421.                 (declare (object kind))
  422.                 (when kind
  423.                       (let ((cvar (next-cvar)))
  424.                            (setf (var-kind var) kind)
  425.                            (setf (var-loc var) cvar)
  426.                            (wt-nl)
  427.                            (unless block-p (wt "{") (setq block-p t))
  428.                            (wt (rep-type kind) "V" cvar ";"))))))
  429.  
  430.         (dolist** (v requireds) (do-decl v))
  431.         (dolist** (opt optionals)
  432.                   (do-decl (car opt))
  433.                   (when (caddr opt) (do-decl (caddr opt))))
  434.         (when rest (do-decl rest))
  435.         (dolist** (kwd keywords)
  436.                   (do-decl (cadr kwd))
  437.                   (when (cadddr kwd) (do-decl (cadddr kwd))))
  438.         )
  439.   ;;; Check arguments.
  440.   (when (and (or *safe-compile* *compiler-check-args*) requireds)
  441.         (when requireds
  442.               (wt-nl "if(vs_top-vs_base<" (length requireds)
  443.                      ") too_few_arguments();")))
  444.  
  445.   ;;; Allocate the parameters.
  446.   (dolist** (var requireds) (setf (var-ref var) (vs-push)))
  447.   (dolist** (opt optionals)
  448.     (setf (var-ref (car opt)) (vs-push)))
  449.   (when rest (setf (var-ref rest) (vs-push)))
  450.   (dolist** (kwd keywords)
  451.     (setf (var-ref (cadr kwd)) (vs-push)))
  452.   (dolist** (kwd keywords)
  453.     (setf (var-ref (cadddr kwd)) (vs-push)))
  454.   (dolist** (opt optionals)
  455.     (when (caddr opt) (setf (var-ref (caddr opt)) (vs-push))))
  456.  
  457.   ;;; Assign rest and keyword parameters first.
  458.   ;;; parse_key does not change vs_base and vs_top.
  459.  
  460.   (wt-nl "parse_key(vs_base")
  461.   (when (or requireds optionals)
  462.         (wt "+" (+ (length requireds) (length optionals))))
  463.   (if rest (wt ",TRUE,") (wt ",FALSE,"))
  464.   (if allow-other-keys (wt "TRUE,") (wt "FALSE,"))
  465.   (wt (length keywords))
  466.   (dolist** (kwd keywords) (wt ",VV[" (add-symbol (car kwd)) "]"))
  467.   (wt ");")
  468.  
  469.   ;;; Bind required parameters.
  470.   (dolist** (var requireds) (c2bind var))
  471.  
  472.   ;;; Bind optional parameters as long as there remain arguments.
  473.   ;;; The compile-time binding is discarded because they are bound again.
  474.  
  475.   (when optionals
  476.  
  477.         (when requireds (wt-nl "vs_base += " (length requireds) ";"))
  478.  
  479.         (let ((*clink* *clink*)
  480.               (*unwind-exit* *unwind-exit*)
  481.               (*ccb-vs* *ccb-vs*))
  482.              (do ((opts optionals (cdr opts)))
  483.                  ((endp opts))
  484.                  (declare (object opts))
  485.                  (push (next-label) labels)
  486.                  (wt-nl "if(vs_base>=vs_top){vs_top=sup;")
  487.                  (wt-go (car labels)) (wt "}")
  488.                  (c2bind (caar opts))
  489.                  (when (caddar opts) (c2bind-loc (caddar opts) t))
  490.                  (when (cdr opts) (wt-nl "vs_base++;"))))
  491.  
  492.         (setq labels (reverse labels))
  493.         )
  494.  
  495.   (wt-nl "vs_top=sup;")
  496.  
  497.   (when optionals
  498.         (let ((label (next-label)))
  499.              (wt-go label)
  500.  
  501.              ;;; Bind unspecified optional parameters.
  502.  
  503.              (dolist** (opt optionals)
  504.                        (wt-label (car labels))
  505.                        (pop labels)
  506.                        (c2bind-init (car opt) (cadr opt))
  507.                        (when (caddr opt) (c2bind-loc (caddr opt) nil)))
  508.  
  509.              (wt-label label)
  510.              ))
  511.  
  512.   (when rest (c2bind rest))
  513.  
  514.   ;;; Bind keywords.
  515.  
  516.   (dolist** (kwd keywords)
  517.     (cond ((and (eq (caaddr kwd) 'LOCATION) (null (caddr (caddr kwd))))
  518.            ;;; Cnil has been set if keyword parameter is not supplied.
  519.            (c2bind (cadr kwd)))
  520.           (t
  521.            (wt-nl "if(") (wt-vs (var-ref (cadddr kwd))) (wt "==Cnil){")
  522.            (let ((*clink* *clink*)
  523.                  (*unwind-exit* *unwind-exit*)
  524.                  (*ccb-vs* *ccb-vs*))
  525.                 (c2bind-init (cadr kwd) (caddr kwd)))
  526.            (wt-nl "}else{")
  527.            (c2bind (cadr kwd))
  528.            (wt "}")))
  529.     (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind (cadddr kwd))))
  530.  
  531.   ;;; Now the parameters are ready, after all!
  532.   (c2expr body)
  533.  
  534.   (when block-p (wt-nl "}"))
  535.   )
  536.  
  537. (defun need-to-set-vs-pointers (lambda-list)
  538.                 ;;; On entry to in-line lambda expression,
  539.                 ;;; vs_base and vs_top must be set iff,
  540.    (or *safe-compile*
  541.        *compiler-check-args*
  542.        (nth 1 lambda-list)    ;;; optional,
  543.        (nth 2 lambda-list)    ;;; rest, or
  544.        (nth 3 lambda-list)    ;;; key-flag.
  545.        ))
  546.  
  547.  
  548. ;;; The DEFMACRO compiler.
  549.  
  550. ;;; valid lambda-list to DEFMACRO is:
  551. ;;;
  552. ;;;    ( [ &whole sym ]
  553. ;;;      [ &environment sym ]
  554. ;;;      { v }*
  555. ;;;      [ &optional { sym | ( v [ init [ v ] ] ) }* ]
  556. ;;;      {  [ { &rest | &body } v ]
  557. ;;;         [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }*
  558. ;;;            [ &allow-other-keys ]]
  559. ;;;         [ &aux { sym | ( v [ init ] ) }* ]
  560. ;;;      |  . sym }
  561. ;;;     )
  562. ;;;
  563. ;;; where v is short for { defmacro-lambda-list | sym }.
  564. ;;; Defamcro-lambda-list is defined as:
  565. ;;;
  566. ;;;    ( { v }*
  567. ;;;      [ &optional { sym | ( v [ init [ v ] ] ) }* ]
  568. ;;;      {  [ { &rest | &body } v ]
  569. ;;;         [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }*
  570. ;;;            [ &allow-other-keys ]]
  571. ;;;         [ &aux { sym | ( v [ init ] ) }* ]
  572. ;;;      |  . sym }
  573. ;;;     )
  574.  
  575. (defvar *vnames*)
  576. (defvar *dm-info*)
  577. (defvar *dm-vars*)
  578.  
  579. (defun c1dm (macro-name vl body
  580.                         &aux (*vs* *vs*) (whole nil) (env nil)
  581.                         (*vnames* nil) (*dm-info* (make-info)) (*dm-vars* nil)
  582.                         doc ss is ts other-decls ppn)
  583.  
  584.   (multiple-value-setq (body ss ts is other-decls doc) (c1body body t))
  585.   (setq body (list (list* 'block macro-name body)))
  586.  
  587.   (c1add-globals ss)
  588.  
  589.   (when (and (listp vl) (eq (car vl) '&whole))
  590.         (push (cadr vl) *vnames*)
  591.         (setq whole (c1make-var (cadr vl) ss is ts))
  592.         (push whole *dm-vars*)
  593.         (push whole *vars*)
  594.         (setq vl (cddr vl))
  595.         )
  596.   (when (and (listp vl) (eq (car vl) '&environment))
  597.         (push (cadr vl) *vnames*)
  598.         (setq env (c1make-var (cadr vl) ss is ts))
  599.         (push env *dm-vars*)
  600.         (push env *vars*)
  601.         (setq vl (cddr vl)))
  602.   (multiple-value-setq (vl ppn) (c1dm-vl vl ss is ts))
  603.  
  604.   (check-vdecl *vnames* ts is)
  605.   (setq body (c1decl-body other-decls body))
  606.   (add-info *dm-info* (cadr body))
  607.   (dolist* (v *dm-vars*) (check-vref v))
  608.  
  609.   (list doc ppn whole env vl body)
  610.   )
  611.  
  612. (defun c1dm-vl (vl ss is ts)
  613.   (do ((optionalp nil) (restp nil) (keyp nil) (allow-other-keys-p nil)
  614.        (auxp nil)
  615.        (requireds nil) (optionals nil) (rest nil) (key-flag nil)
  616.        (keywords nil) (auxs nil) (allow-other-keys nil)
  617.        (n 0) (ppn nil)
  618.        )
  619.     ((not (consp vl))
  620.      (when vl
  621.            (when restp (dm-bad-key '&rest))
  622.            (setq rest (c1dm-v vl ss is ts)))
  623.      (values (list (reverse requireds) (reverse optionals) rest key-flag
  624.                    (reverse keywords) allow-other-keys (reverse auxs))
  625.              ppn)
  626.      )
  627.     (let ((v (car vl)))
  628.          (declare (object v))
  629.       (cond
  630.        ((eq v '&optional)
  631.         (when optionalp (dm-bad-key '&optional))
  632.         (setq optionalp t)
  633.         (pop vl))
  634.        ((or (eq v '&rest) (eq v '&body))
  635.         (when restp (dm-bad-key v))
  636.         (setq rest (c1dm-v (cadr vl) ss is ts))
  637.         (setq restp t optionalp t)
  638.         (setq vl (cddr vl))
  639.         (when (eq v '&body) (setq ppn n)))
  640.        ((eq v '&key)
  641.         (when keyp (dm-bad-key '&key))
  642.         (setq keyp t restp t optionalp t key-flag t)
  643.         (pop vl))
  644.        ((eq v '&allow-other-keys)
  645.         (when (or (not keyp) allow-other-keys-p)
  646.               (dm-bad-key '&allow-other-keys))
  647.         (setq allow-other-keys-p t allow-other-keys t)
  648.         (pop vl))
  649.        ((eq v '&aux)
  650.         (when auxp (dm-bad-key '&aux))
  651.         (setq auxp t allow-other-keys-p t keyp t restp t optionalp t)
  652.         (pop vl))
  653.        (auxp
  654.         (let (x init)
  655.              (cond ((symbolp v) (setq x v init (c1nil)))
  656.                    (t (setq x (car v))
  657.                       (if (endp (cdr v))
  658.                           (setq init (c1nil))
  659.                           (setq init (c1expr* (cadr v) *dm-info*)))))
  660.              (push (list (c1dm-v x ss is ts) init) auxs))
  661.         (pop vl))
  662.        (keyp
  663.         (let (x k init (sv nil))
  664.              (cond ((symbolp v)
  665.                     (setq x v k (intern (string v) 'keyword) init (c1nil)))
  666.                    (t (if (symbolp (car v))
  667.                           (setq x (car v)
  668.                                 k (intern (string (car v)) 'keyword))
  669.                           (setq x (cadar v) k (caar v)))
  670.                       (cond ((endp (cdr v)) (setq init (c1nil)))
  671.                             (t (setq init (c1expr* (cadr v) *dm-info*))
  672.                                (unless (endp (cddr v))
  673.                                        (setq sv (caddr v)))))))
  674.              (push (list k (c1dm-v x ss is ts) init
  675.                          (if sv (c1dm-v sv ss is ts) nil))
  676.                    keywords)
  677.              )
  678.         (pop vl))
  679.        (optionalp
  680.         (let (x init (sv nil))
  681.              (cond ((symbolp v) (setq x v init (c1nil)))
  682.                    (t (setq x (car v))
  683.                       (cond ((endp (cdr v))
  684.                              (setq init (c1nil)))
  685.                             (t (setq init (c1expr* (cadr v) *dm-info*))
  686.                                (unless (endp (cddr v))
  687.                                        (setq sv (caddr v)))))))
  688.              (push (list (c1dm-v x ss is ts) init
  689.                          (if sv (c1dm-v sv ss is ts) nil))
  690.                    optionals))
  691.         (pop vl)
  692.         (incf n)
  693.         )
  694.        (t (push (c1dm-v v ss is ts) requireds)
  695.           (pop vl)
  696.           (incf n))
  697.        )))
  698.   )
  699.  
  700. (defun c1dm-v (v ss is ts)
  701.        (cond ((symbolp v)
  702.               (push v *vnames*)
  703.               (setq v (c1make-var v ss is ts))
  704.               (push v *vars*)
  705.               (push v *dm-vars*)
  706.               v)
  707.              (t (c1dm-vl v ss is ts))))
  708.  
  709. (defun c1dm-bad-key (key)
  710.        (cmperr "Defmacro-lambda-list contains illegal use of ~s." key))
  711.  
  712. (defun c2dm (whole env vl body
  713.                    &aux (cvar (next-cvar)))
  714.   (when (or *safe-compile* *compiler-check-args*)
  715.     (wt-nl "check_arg(2);"))
  716.   (cond (whole (setf (var-ref whole) (vs-push)))
  717.         (t (vs-push)))
  718.   (cond (env (setf (var-ref env) (vs-push)))
  719.         (t (vs-push)))
  720.   (c2dm-reserve-vl vl)
  721.   (wt-nl "vs_top=sup;")
  722.   (when whole (c2bind whole))
  723.   (when env (c2bind env))
  724.   (wt-nl "{object V" cvar "=base[0]->c.c_cdr;")
  725.   (c2dm-bind-vl vl cvar)
  726.   (wt "}")
  727.   (c2expr body)
  728.   )
  729.  
  730. (defun c2dm-reserve-vl (vl)
  731.   (dolist** (var (car vl)) (c2dm-reserve-v var))
  732.   (dolist** (opt (cadr vl))
  733.             (c2dm-reserve-v (car opt))
  734.             (when (caddr opt) (c2dm-reserve-v (caddr opt))))
  735.   (when (caddr vl) (c2dm-reserve-v (caddr vl)))
  736.   (dolist** (kwd (car (cddddr vl)))
  737.             (c2dm-reserve-v (cadr kwd))
  738.             (when (cadddr kwd) (c2dm-reserve-v (cadddr kwd))))
  739.   (dolist** (aux (caddr (cddddr vl)))
  740.             (c2dm-reserve-v (car aux)))
  741.   )
  742.  
  743. (defun c2dm-reserve-v (v)
  744.   (if (consp v)
  745.       (c2dm-reserve-vl v)
  746.       (setf (var-ref v) (vs-push))))
  747.  
  748. (defun c2dm-bind-vl (vl cvar
  749.                         &aux
  750.                         (requireds (car vl)) (optionals (cadr vl))
  751.                         (rest (caddr vl)) (key-flag (cadddr vl))
  752.                         (keywords (car (cddddr vl)))
  753.                         (allow-other-keys (cadr (cddddr vl)))
  754.                         (auxs (caddr (cddddr vl)))
  755.                         )
  756.   (declare (object requireds optionals rest key-flag keywords allow-other-keys
  757.                    auxs))
  758.   (do ((reqs requireds (cdr reqs)))
  759.       ((endp reqs))
  760.       (declare (object reqs))
  761.       (when (or *safe-compile* *compiler-check-args*)
  762.             (wt-nl "if(endp(V" cvar "))invalid_macro_call();"))
  763.       (c2dm-bind-loc (car reqs) `(car ,cvar))
  764.       (when (or (cdr reqs) optionals rest key-flag
  765.                 *safe-compile* *compiler-check-args*)
  766.             (wt-nl "V" cvar "=V" cvar "->c.c_cdr;")))
  767.   (do ((opts optionals (cdr opts)))
  768.       ((endp opts))
  769.       (declare (object opts))
  770.       (let ((opt (car opts)))
  771.            (declare (object opt))
  772.            (wt-nl "if(endp(V" cvar ")){")
  773.            (let ((*clink* *clink*)
  774.                  (*unwind-exit* *unwind-exit*)
  775.                  (*ccb-vs* *ccb-vs*))
  776.                 (c2dm-bind-init (car opt) (cadr opt))
  777.                 (when (caddr opt) (c2dm-bind-loc (caddr opt) nil))
  778.                 )
  779.            (wt-nl "} else {")
  780.            (c2dm-bind-loc (car opt) `(car ,cvar))
  781.            (when (caddr opt) (c2dm-bind-loc (caddr opt) t)))
  782.       (when (or (cdr opts) rest key-flag
  783.                 *safe-compile* *compiler-check-args*)
  784.             (wt-nl "V" cvar "=V" cvar "->c.c_cdr;"))
  785.       (wt "}"))
  786.   (when rest (c2dm-bind-loc rest `(cvar ,cvar)))
  787.   (dolist** (kwd keywords)
  788.     (let ((cvar1 (next-cvar)))
  789.          (wt-nl
  790.           "{object V" cvar1 "=getf(V" cvar ",VV[" (add-symbol (car kwd))
  791.           "],OBJNULL);")
  792.          (wt-nl "if(V" cvar1 "==OBJNULL){")
  793.          (let ((*clink* *clink*)
  794.                (*unwind-exit* *unwind-exit*)
  795.                (*ccb-vs* *ccb-vs*))
  796.               (c2dm-bind-init (cadr kwd) (caddr kwd))
  797.               (when (cadddr kwd) (c2dm-bind-loc (cadddr kwd) nil))
  798.               (wt-nl "} else {"))
  799.          (c2dm-bind-loc (cadr kwd) `(cvar ,cvar1))
  800.          (when (cadddr kwd) (c2dm-bind-loc (cadddr kwd) t))
  801.          (wt "}}")))
  802.   (when (and (or *safe-compile* *compiler-check-args*)
  803.              (null rest)
  804.              (null key-flag))
  805.         (wt-nl "if(!endp(V" cvar "))invalid_macro_call();"))
  806.   (when (and (or *safe-compile* *compiler-check-args*)
  807.              key-flag
  808.              (not allow-other-keys))
  809.         (wt-nl "check_other_key(V" cvar "," (length keywords))
  810.         (dolist** (kwd keywords)
  811.                   (wt ",VV[" (add-symbol (car kwd)) "]"))
  812.         (wt ");"))
  813.   (dolist** (aux auxs)
  814.             (c2dm-bind-init (car aux) (cadr aux)))
  815.   )
  816.  
  817. (defun c2dm-bind-loc (v loc)
  818.   (if (consp v)
  819.       (let ((cvar (next-cvar)))
  820.            (wt-nl "{object V" cvar "= " loc ";")
  821.            (c2dm-bind-vl v cvar)
  822.            (wt "}"))
  823.       (c2bind-loc v loc)))
  824.  
  825. (defun c2dm-bind-init (v init)
  826.   (if (consp v)
  827.       (let* ((*vs* *vs*) (*inline-blocks* 0)
  828.              (cvar (next-cvar))
  829.              (loc (car (inline-args (list init) '(t)))))
  830.             (wt-nl "{object V" cvar "= " loc ";")
  831.             (c2dm-bind-vl v cvar)
  832.             (wt "}")
  833.             (close-inline-blocks))
  834.       (c2bind-init v init)))
  835.  
  836.  
  837.  
  838.